home *** CD-ROM | disk | FTP | other *** search
/ Best of Shareware / Best of PC Windows Shareware 1.0 - Wayzata Technology (7111) (1993).iso / mac / ZIPPED / DOS / PROGRAMG / FORTHCMP.ZIP / DOS2.4TH < prev    next >
Text File  |  1992-03-30  |  5KB  |  114 lines
  1. ( DOSINT FILE INTERFACE                        12/15/86 )
  2. \ Code Copyright (C) 1986 by Thomas Almy.  All rights reserved.
  3. \ Permission is granted to registered users of ForthCMP to sell or distribute
  4. \ computer programs incorporating the compiled contents of this file.
  5.  
  6.  
  7. \ This file is intended to behave like UR/FORTH's "DOSINT"
  8. \ interface. There are some differences (such as "closed" in the level
  9. \ two functions being -1 so as not to interfere with standard input.
  10.  
  11. \ This file must be included after the application, just before
  12. \ "FORTHLIB".  the file "DOS1" should be included before the application.
  13.  
  14. \   Enjoy!
  15.  
  16. \   Tom
  17.  
  18.  
  19. 10 DECIMAL .( Loading DOS2) CR
  20.  
  21. \ Erzatz String Support 
  22. FIND STRBUF #IF DROP ( good news ) #ELSE  ( fake it )
  23. DSEG
  24. CREATE sB1 80 ALLOT CREATE sB2 80 ALLOT
  25. VARIABLE sBSW  sB1 sBSW !
  26. 1 1 IN/OUT
  27. : ASCIIZ  COUNT >R
  28. \  sBSW @ sB1 = IF sB2 ELSE sB1 THEN DUP sBSW !
  29.    sBSW @ sB1 sB2 XOR XOR DUP sBSW !
  30.    R@ CMOVE
  31.    R> sBSW @ + 0 C<-
  32.    sBSW @ ;      #THEN
  33.  
  34. U: .FNAME  2+ COUNT TYPE ;
  35. U: HCB>N 2+ ;
  36. U: HCB>H @ ;
  37. U: NAME>HCB DUP FCLOSE DROP 2+ OVER C@ 1+ CMOVE ;
  38. U: FMAKE     OVER DUP  @ 0< NOT IF 2DROP DROP -1 EXIT THEN
  39.             2+ SWAP creat DUP -1 =  IF NIP EXIT THEN <- 0 ;
  40. U: FOPEN     OVER DUP  @ 0< NOT IF 2DROP DROP -1 EXIT THEN
  41.             2+ SWAP open DUP -1 =  IF NIP EXIT THEN <- 0 ;
  42. UNDEF open  CODE open  SI POP BX POP AX POP BX PUSH SI PUSH
  43.     CALL' ASCIIZ  SI POP AX DX MOV AX POP
  44.     61 # AH MOV  33 INT  ( ' seterr JMP ) END-CODE #THEN
  45. L: seterr  <U ~ IF, 0 # errno [] MOV ELSE, AX errno [] MOV
  46.      -1 # AX MOV THEN, AX PUSH SI JMP END-CODE
  47. L: retstat  <U ~ IF, AX AX XOR AX errno [] MOV ELSE,
  48.      AX errno [] MOV -1 # AX MOV THEN, AX PUSH SI JMP END-CODE
  49. UNDEF creat CODE creat SI POP BX POP AX POP BX PUSH SI PUSH
  50.     CALL' ASCIIZ  SI POP AX DX MOV CX POP
  51.     60 # AH MOV 33 INT seterr JMP END-CODE #THEN
  52. U: FSEEK  >R >R >R  @  R> R> R>  3 PICK 0< NOT IF lseek EXIT THEN 2DROP 2DROP -1. ;
  53. UNDEF lseek
  54. CODE lseek  SI POP  AX POP  CX POP  DX POP  BX POP
  55.    66 # AH MOV  33 INT  <U IF, AX errno [] MOV
  56.    -1 # AX MOV AX PUSH AX PUSH SI JMP THEN,
  57.   0 # errno [] MOV AX PUSH DX PUSH SI JMP END-CODE #THEN
  58. U: FDEL  DUP @ 0< NOT IF DROP -1 EXIT THEN 2+ unlink ;
  59. UNDEF unlink
  60. CODE unlink SI POP AX POP SI PUSH CALL' ASCIIZ SI POP
  61.     AX DX MOV  65 # AH MOV  33 INT retstat JMP END-CODE #THEN
  62. U: FREAD ROT @ ?opn  IF -ROT ?DS: -ROT 63 r/w EXIT THEN
  63.              2DROP 0  ;
  64. U: FWRITE ROT @ ?opn  IF -ROT ?DS: -ROT 64 r/w EXIT THEN
  65.              2DROP 0  ;
  66. U: FREADL >R ROT @ ?opn IF -ROT R> 63 r/w EXIT THEN R> DROP 2DROP 0 ;
  67. U: FWRITEL >R ROT @ ?opn IF -ROT R> 64 r/w EXIT THEN R> DROP 2DROP 0 ;
  68. U: readl 63 r/w ;
  69. U: read ?DS: -ROT 63 r/w ;
  70. U: writel  64 r/w ;
  71. U: write ?DS: -ROT 64 r/w ;
  72. UNDEF r/w  CODE r/w ( handle seg buf len  command -- results.. )
  73.   SI POP AX POP  AL AH MOV  CX POP  DX POP  DI DS <SEG
  74.   DS POPSEG BX POP 33 INT DI DS >SEG
  75.   <U ~ IF, 0 # errno [] MOV ELSE, AX errno [] MOV
  76.      AX AX XOR THEN, AX PUSH SI JMP END-CODE    #THEN
  77. U: FCLOSE    DUP @ ?opn IF close ELSE -1 THEN SWAP ON ;
  78. PRIMITIVE U: ?opn DUP 0< IF DROP 0 ELSE -1 THEN ;
  79. UNDEF close CODE close  SI POP  BX POP 62 # AH MOV
  80.    33 INT retstat JMP END-CODE #THEN
  81. UNDEF chmod CODE chmod SI POP CX POP AX POP CX PUSH SI PUSH
  82.    CALL' ASCIIZ AX DX MOV SI POP CX POP -1 # CX CMP
  83.    =0 IF, HEX 4300 # AX MOV ELSE, 4301 # AX MOV THEN, DECIMAL
  84.    33 INT <U ~ IF, 0 # errno [] MOV CX PUSH SI JMP THEN,
  85.    AX errno [] MOV -1 # AX MOV AX PUSH SI JMP END-CODE #THEN
  86. U: FREN  OVER @ OVER @ AND 0< IF 2DROP -1 EXIT THEN
  87.             2+ SWAP 2+ SWAP rename ;
  88. UNDEF rename CODE rename SI POP AX POP SI PUSH CALL' ASCIIZ
  89.    SI POP AX BX MOV AX POP SI PUSH BX PUSH CALL' ASCIIZ
  90.    AX DX MOV DI POP SI POP DS PUSHSEG ES POPSEG
  91.    86 # AH MOV 33 INT retstat JMP  END-CODE #THEN
  92. U: FCHDIR DUP @ 0< NOT IF DROP -1 EXIT THEN 2+ chdir ;
  93. U: FMKDIR DUP @ 0< NOT IF DROP -1 EXIT THEN 2+ mkdir ;
  94. U: FRMDIR DUP @ 0< NOT IF DROP -1 EXIT THEN 2+ rmdir ;
  95. ?DEFINE chdir ?DEFINE mkdir ?DEFINE rmdir OR OR #IF
  96. L: dircmd SI POP AX POP BX PUSH SI PUSH CALL' ASCIIZ
  97.  SI POP AX DX MOV AX POP 33 INT retstat JMP END-CODE #THEN
  98. UNDEF chdir CODE chdir 59 # BH MOV dircmd JMP END-CODE #THEN
  99. UNDEF mkdir CODE mkdir 57 # BH MOV dircmd JMP END-CODE #THEN
  100. UNDEF rmdir CODE rmdir 58 # BH MOV dircmd JMP END-CODE #THEN
  101. UNDEF getdir
  102.   1 0 IN/OUT CODE (getdir) AX SI MOV 0 # DL MOV 71 # AH MOV
  103.   33 INT RET END-CODE
  104. FIND STRBUF #IF DROP
  105. : getdir 64 +STRBUF STRBUF (getdir) STRBUF -ASCIIZ ; #ELSE
  106. : getdir sB1 1+ (getdir) sB1 1+ 64 0 SCAN DROP sB1 1+ -
  107.    sB1 C!  sB1 ; #THEN #THEN
  108. UNDEF firstf CODE firstf SI POP BX POP AX POP BX PUSH SI PUSH
  109.    CALL' ASCIIZ SI POP CX POP AX DX MOV 78 # AH MOV 33 INT
  110.    retstat JMP END-CODE #THEN
  111. UNDEF nextf CODE nextf SI POP 79 # AH MOV 33 INT retstat JMP
  112.    END-CODE #THEN
  113. 16 = #IF HEX #THEN
  114.